PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/cert/trk3_eg/dde/dde_piz/dde_piz.frm

Visual Basic Form | 1994-09-28 | 20.9 KB | 604 lines

VERSION 2.00
Begin Form frmPizza
   BackColor       =   &H000000C0&
   Caption         =   "VBits-a-Hut"
   ClientHeight    =   4665
   ClientLeft      =   1320
   ClientTop       =   2265
   ClientWidth     =   7365
   Height          =   5355
   Icon            =   DDE_PIZ.FRX:0000
   Left            =   1260
   LinkTopic       =   "Form1"
   ScaleHeight     =   4665
   ScaleWidth      =   7365
   Top             =   1635
   Width           =   7485
   Begin CommonDialog CMOpenXl
      Left            =   240
      Top             =   3960
   End
   Begin CommandButton Command1
      Caption         =   "&New Order"
      Height          =   435
      Left            =   2760
      TabIndex        =   9
      Top             =   120
      Width           =   1500
   End
   Begin Frame grpMethod
      Caption         =   "Pickup/Delivery"
      Enabled         =   0   'False
      Height          =   1095
      Left            =   4440
      TabIndex        =   11
      Top             =   120
      Width           =   2655
      Begin OptionButton optMethod
         Caption         =   "&Delivery"
         Enabled         =   0   'False
         Height          =   255
         Index           =   1
         Left            =   240
         TabIndex        =   13
         Top             =   720
         Width           =   1095
      End
      Begin OptionButton optMethod
         Caption         =   "Pick&up"
         Enabled         =   0   'False
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   12
         Top             =   360
         Value           =   -1  'True
         Width           =   1935
      End
   End
   Begin CommandButton cmdClear
      Caption         =   "C&lear Pizza"
      Height          =   495
      Left            =   5160
      TabIndex        =   15
      Top             =   3960
      Width           =   1755
   End
   Begin TextBox txtName
      Height          =   315
      Left            =   240
      TabIndex        =   1
      Top             =   360
      Width           =   2115
   End
   Begin Frame grpTopping
      BackColor       =   &H00FFFFFF&
      Caption         =   "&Toppings"
      Height          =   1515
      Left            =   240
      TabIndex        =   2
      Top             =   840
      Width           =   2115
      Begin CheckBox chkTopping
         BackColor       =   &H00FFFFFF&
         Caption         =   "&Pepperoni"
         Height          =   315
         Index           =   1
         Left            =   120
         TabIndex        =   4
         Top             =   720
         Width           =   1665
      End
      Begin CheckBox chkTopping
         BackColor       =   &H00FFFFFF&
         Caption         =   "Mu&shrooms"
         Height          =   315
         Index           =   2
         Left            =   120
         TabIndex        =   5
         Top             =   1080
         Width           =   1440
      End
      Begin CheckBox chkTopping
         BackColor       =   &H00FFFFFF&
         Caption         =   "&Cheese"
         Height          =   315
         Index           =   0
         Left            =   120
         TabIndex        =   3
         Top             =   375
         Width           =   1815
      End
   End
   Begin CommandButton cmdPickup
      Caption         =   "&Get Pizza"
      Enabled         =   0   'False
      Height          =   495
      Left            =   3000
      TabIndex        =   14
      Top             =   3960
      Width           =   1740
   End
   Begin CommandButton cmdOrder
      Caption         =   "Place &Order"
      Enabled         =   0   'False
      Height          =   435
      Left            =   2760
      TabIndex        =   10
      Top             =   720
      Width           =   1500
   End
   Begin PictureBox picPizza
      Height          =   2415
      Left            =   2760
      ScaleHeight     =   2385
      ScaleWidth      =   4335
      TabIndex        =   17
      Top             =   1440
      Width           =   4365
   End
   Begin Frame frmCrust
      BackColor       =   &H00FFFFFF&
      Caption         =   "Thick or Thin Crust"
      Height          =   1140
      Left            =   240
      TabIndex        =   6
      Top             =   2640
      Width           =   2115
      Begin OptionButton optThick
         BackColor       =   &H00FFFFFF&
         Caption         =   "&Thick Crust"
         Height          =   315
         Left            =   300
         TabIndex        =   8
         Top             =   675
         Width           =   1440
      End
      Begin OptionButton optThin
         BackColor       =   &H00FFFFFF&
         Caption         =   "T&hin Crust"
         Height          =   240
         Left            =   300
         TabIndex        =   7
         Top             =   375
         Value           =   -1  'True
         Width           =   1365
      End
   End
   Begin Label lblName
      BackStyle       =   0  'Transparent
      Caption         =   "Na&me"
      Height          =   240
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1440
   End
   Begin Label lblPizza
      BackStyle       =   0  'Transparent
      Caption         =   "Pizza"
      Height          =   240
      Left            =   2775
      TabIndex        =   16
      Top             =   1200
      Width           =   1140
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuPizza
      Caption         =   "&Pizza"
      Begin Menu mnuPizzaNew
         Caption         =   "&New Order"
         Shortcut        =   ^N
      End
      Begin Menu mnuPizzaOrder
         Caption         =   "Place &Order"
         Enabled         =   0   'False
         Shortcut        =   ^O
      End
      Begin Menu mnuPizzaClear
         Caption         =   "C&lear Pizza"
         Enabled         =   0   'False
         Shortcut        =   ^L
      End
      Begin Menu mnuPizzaSep1
         Caption         =   "-"
      End
      Begin Menu mnuPizzaOptions
         Caption         =   "&Pickup"
         Checked         =   -1  'True
         Enabled         =   0   'False
         Index           =   0
         Shortcut        =   ^P
      End
      Begin Menu mnuPizzaOptions
         Caption         =   "&Delivery"
         Enabled         =   0   'False
         Index           =   1
         Shortcut        =   ^D
      End
      Begin Menu mnuPizzaSep2
         Caption         =   "-"
      End
      Begin Menu mnuPizzaGet
         Caption         =   "&Get Pizza"
         Enabled         =   0   'False
         Shortcut        =   ^G
      End
   End
   Begin Menu mnuHelp
      Caption         =   "&Help"
      Begin Menu mnuHelpAbout
         Caption         =   "&About"
      End
   End
Option Explicit
'Form level variables
Dim Man_Auto As Integer
Dim glbPath As String
Dim CurDrive As String
Dim rc As Integer
Dim cnt As Integer
Dim lf As String
Dim flgDDEON As Integer
Dim DDEAPP As String
'Form level constants
Const NONE = 0
Const AUTOMATIC = 1
Const LINK_MANUAL = 2 ' Declare constants.
Const NOFILE = 53
Const BADCALL = 5
Const BADPATH = 76
Const NOAPP = 282
Const XLFILE = "pizza.xls"
' WindowState
Const NORMAL = 0    ' 0 - Normal
Const MINIMIZED = 1 ' 1 - Minimized
Const MAXIMIZED = 2 ' 2 - Maximized
Const NORMALWOFOCUS = 4 ' 4 - Normal without Focus
' Check Value
Const UNCHECKED = 0 ' 0 - Unchecked
Const Checked = 1   ' 1 - Checked
Const GRAYED = 2    ' 2 - Grayed
' MsgBox parameters
Const MB_OK = 0                 ' OK button only
Const MB_OKCANCEL = 1           ' OK and Cancel buttons
Const MB_ABORTRETRYIGNORE = 2   ' Abort, Retry, and Ignore buttons
Const MB_YESNOCANCEL = 3        ' Yes, No, and Cancel buttons
Const MB_YESNO = 4              ' Yes and No buttons
Const MB_RETRYCANCEL = 5        ' Retry and Cancel buttons
Const MB_ICONSTOP = 16          ' Critical message
Const MB_ICONQUESTION = 32      ' Warning query
Const MB_ICONEXCLAMATION = 48   ' Warning message
Const MB_ICONINFORMATION = 64   ' Information message
Const MB_APPLMODAL = 0          ' Application Modal Message Box
Const MB_DEFBUTTON1 = 0         ' First button is default
Const MB_DEFBUTTON2 = 256       ' Second button is default
Const MB_DEFBUTTON3 = 512       ' Third button is default
Const MB_SYSTEMMODAL = 4096      'System Modal
' MsgBox return values
Const IDOK = 1                  ' OK button pressed
Const IDCANCEL = 2              ' Cancel button pressed
Const IDABORT = 3               ' Abort button pressed
Const IDRETRY = 4               ' Retry button pressed
Const IDIGNORE = 5              ' Ignore button pressed
Const IDYes = 6                 ' Yes button pressed
Const IDNO = 7                  ' No button pressed
Sub ButtonsON ()
    grpMethod.enabled = True        'Enable Method of Pickup Group
    optMethod(0).enabled = True     'Enable Pickup option button
    optMethod(1).enabled = True     'Enable Pickup option button
    optMethod(0).Value = True     'Enable Pickup option button
    cmdPickup.enabled = True        'Enable Pickup Button
    mnuPizzaOptions(0).enabled = True
    mnuPizzaOptions(1).enabled = True
    mnuPizzaGet.enabled = True
    mnuPizzaClear.enabled = True
End Sub
Sub chkTopping_Click (index As Integer)
If cmdOrder.enabled Then    'Test in Order button on
    Call PlaceOrder     'Call PlaceOrder Subroutine
End If
End Sub
Sub cmdClear_Click ()
    Call myClearPizza
End Sub
Sub cmdOrder_Click ()
Call myPlaceOrder
End Sub
Sub cmdPickup_Click ()
    Call PlaceOrder    'Call PlaceOrder Subroutine
    picPizza.LinkRequest
End Sub
Sub Command1_Click ()
txtName.Text = ""
End Sub
Sub FindGlbPath ()
glbPath = App.Path          'Assign glbPath to current path
If Not Right$(glbPath, 1) = "\" Then     'Check if root dir c:\
    glbPath = glbPath & "\"       'Add a "\" if necessary
End If
CurDrive = Left$(glbPath, 2)
End Sub
Sub Form_Load ()
lf = Chr$(10)   'Variable for line feed in msgboxes
Call FindGlbPath     'Find current path
flgDDEON = False     'Flag DDE on or off
DDEAPP$ = "EXCEL"
Me.Move (screen.Height - Height) \ 2, (screen.Width - Width) \ 2
End Sub
Sub Form_Unload (Cancel As Integer)
    picPizza.LinkMode = NONE        'Clears DDE Connection
    txtName.LinkMode = NONE         'Clears Text Connection
End Sub
Sub GenErr (proc$, errnum%, errstr$)
MsgBox "An unexpected error has occur!!!!" & lf & "Error Number: " & errnum & lf & "Error message: " & errstr, MB_OK, "ERROR!!!"
End Sub
Sub mnuExit_Click ()
Unload Me
End Sub
Sub mnuHelpAbout_Click ()
frmAbout.Show 1
End Sub
Sub mnuPizzaClear_Click ()
Call myClearPizza
End Sub
Sub mnuPizzaGet_Click ()
    Call PlaceOrder    'Call PlaceOrder Subroutine
    picPizza.LinkRequest
End Sub
Sub mnuPizzaNew_Click ()
txtName.Text = ""
txtName.SetFocus
End Sub
Sub mnuPizzaOptions_Click (index As Integer)
optMethod(index).Value = True
End Sub
Sub mnuPizzaOrder_Click ()
Call myPlaceOrder
End Sub
Sub mnuPizzaPickup_Click ()
    Call PlaceOrder    'Call PlaceOrder Subroutine
    picPizza.LinkRequest
End Sub
Sub myChooseMethod (myindex As Integer)
On Error GoTo mychooseMethodErr
Select Case myindex    'Click Pickup pizza
    Case 0
    cmdPickup.enabled = True        'Set Pickup button to enabled
    mnuPizzaGet.enabled = True      'Enables Get menu
    picPizza.LinkMode = NONE        'Clear DDE Channel
    picPizza.LinkMode = LINK_MANUAL     'Set DDE to Manual
    mnuPizzaOptions(0).Checked = True
    mnuPizzaOptions(1).Checked = False
    Case 1           'Click Deliver pizza
    cmdPickup.enabled = False       'Set Pickup button to disabled
    mnuPizzaGet.enabled = False      'Disable Get menu
    picPizza.LinkMode = NONE        'Cleat DDE Channel
    picPizza.LinkMode = AUTOMATIC   'Set DDE to AUTOMATIC
    mnuPizzaOptions(0).Checked = False
    mnuPizzaOptions(1).Checked = True
End Select
Exit Sub
mychooseMethodErr:
    GenErr "startxl", Err, Error$
    End
End Sub
Sub myClearAll ()
    flgDDEON = False          'Flag that indicates no DDE
    picPizza.LinkMode = NONE   'Clear DDE channel
    picPizza.LinkTopic = ""
    picPizza.LinkItem = ""
    picPizza.LinkMode = NONE   'Clear DDE channel
    picPizza = LoadPicture("")   'Clear picture box
    txtName.Text = ""            'Clear order name text box
    For cnt = 0 To 2             'Loop through all check boxes
    chkTopping(cnt).Value = UNCHECKED    'Set value to unchecked
    Next
    optMethod(0).Value = True       'Reset buttons
    grpMethod.enabled = False
    optMethod(0).enabled = False
    optMethod(1).enabled = False
    cmdPickup.enabled = False
    mnuPizzaOptions(0).enabled = False
    mnuPizzaOptions(1).enabled = False
    mnuPizzaGet.enabled = False
    mnuPizzaClear.enabled = False
End Sub
Sub myClearPizza ()
If optMethod(0).Value = True Then
    picPizza = LoadPicture("")   'Clear picture box
    MsgBox "You can not clear the pizza when you have free delivery.  The pizza keeps coming."
End If
End Sub
Sub myPlaceOrder ()
On Error GoTo errcmdOrder_Click     'Error Trap
startAGain:                         'Label incase of Error
    picPizza.LinkMode = NONE        'Clear DDE Connection
    picPizza = LoadPicture("")   'Clear picture box                                    'Clears Picture
    'Set LinkTopic to excel and file in excel
    picPizza.LinkTopic = "Excel|[pizza.xls]sheet1 pizza"   ' Set link topic.
    picPizza.LinkItem = "pizza"       ' Set link item to chart in xl.
    picPizza.LinkMode = LINK_MANUAL   ' Set link mode to Manual.
    flgDDEON = True                   'Set flgDDE to True
    Call PlaceOrder         'Call PlaceOrder subroutine
    Call ButtonsON          'Call ButtonsOn subroutine
Exit Sub                    'Exit Sub so not to fall in Error trap
errcmdOrder_Click:          'Label for Error trap
    If Err = NOAPP Then     'Test if Err NOAPP (282)
    rc = myStartDDE()      'Try starting xl by calling Startxl procedure
    If rc = False Then  'If can't start xl then end Application
        End             'Ends App
    Else                'Else try DDE connection again
       Resume startAGain     'Resume at StartAgain label
    End If
    Else                    'If not NoApp err call GenErr
    GenErr "cmdOrder_Click", Err, Error$   'GenErr pass procedure name, err and err msg
    End If
End Sub
Function myStartDDE () As Integer
Dim xlRun As Integer
On Error GoTo ErrDDE:
DDEStart:
picPizza.LinkMode = NONE     'Clear DDE channel
'Set LinkTopic to Excel, App is Excel
'Topic is System which means general Excel no file
picPizza.LinkTopic = "Excel|system"
'Set LinkTimeout to 10 seconds
picPizza.LinkTimeout = 1000
'Set LinkMode to manual
picPizza.LinkMode = LINK_MANUAL    ' Set link mode.
'LinkExecute to Open a file in Excel
picPizza.LinkExecute "[Open(""" & glbPath & XLFILE & """)]"
myStartDDE = True       'Set Startxl to true
DoEvents             'Doevents lets xl startup successfully
Exit Function        'Exit Function prevents fall thru to error trap
ErrDDE:
If Err = NOAPP Then
    xlRun = myStartXL()           'Start Excel
    If xlRun = True Then          'Test is EXCEl is running
    Resume DDEStart           'Try to DDE again
    Else
    myStartDDE = False         'Set startxl flag to false
    Exit Function             'End function
    End If
Else        'if unexpect error call GenErr
    GenErr "startxl", Err, Error$
End If
End Function
Function myStartXL () As Integer
Dim App As String
Dim z As Variant
Dim trycnt As Integer
Dim rc As Integer
On Error GoTo errStartxl    'Set Error Trap
    App$ = "EXCEL"
    z = Shell(App$, MINIMIZED)  'Start xl with shell function
    'If can't open and error will occur
    myStartXL = True
Exit Function
errStartxl:
If Err = NOFILE Or Err = BADCALL Or Err = BADPATH Then        'Test err to see if found xl
trycnt% = trycnt% + 1         'if Shell fails it is because Excel not in path
Select Case trycnt%
Case 1     'Try to see if Excel is in default locaton
    App$ = CurDrive & "\EXCEL\EXCEL.EXE"
    Resume 'Try shell again
Case 2     'Try to see if Excel is in default MSOffice location
    App$ = CurDrive & "\MSOffice\EXCEL\EXCEL.EXE"
    Resume 'Try shell again
Case 3     'Try to see if Excel is in default MSOffice location
    App$ = CurDrive & "\EXCEL5\EXCEL.EXE"
    Resume 'Try shell again
Case Else       'Call Open Dialog Box and have user find EXCEL
    Do
    'Set Filter to check for EXCEL
    cmOpenxl.Filter = "Programs (*.exe)|*.exe|All files (*.*)|*.*"
    cmOpenxl.Filename = ""      'Reset Filename to empty
    cmOpenxl.Action = 1         'Call the OPen dialog box
    App$ = cmOpenxl.Filename    'Set App$ to filename choosen
    If Len(App$) > 0 Then
        If cmOpenxl.Filetitle = DDEAPP$ & ".EXE" Then
        Exit Do       'Test if enter a name or cancel
        ElseIf cmOpenxl.Filetitle <> DDEAPP$ & ".EXE" Then
        MsgBox "You have selected a file that is not " & DDEAPP$ & ".", MB_ICONEXCLAMATION, "OOPS"
        ElseIf Right$(cmOpenxl.Filetitle, 4) <> ".EXE" Then
        MsgBox "This file is not a executeable.", MB_ICONEXCLAMATION, "OOPS"
        End If
        App$ = ""               'Clear out App so no shell will occur
    End If
    Loop While MsgBox("Please find the application Excel or hit cancel to end application", MB_OKCANCEL + MB_ICONQUESTION, "Find Excel") = IDOK
    'Test if found Excel or hit cancel
    If Len(App$) > 0 Then
    Resume
    Else
    MsgBox "Excel must be loaded to order pizza." & lf & lf & "Sorry" & lf & "Please check if Excel is on your machine.", MB_ICONSTOP
    myStartXL = False         'Set startxl flag to false
    Exit Function             'End function
    End If
End Select
Else        'if unexpect error call GenErr
    GenErr "startxl", Err, Error$
End If
End Function
Sub optMethod_Click (index As Integer)
If flgDDEON = True Then
    Call myChooseMethod(index)
End If
End Sub
Sub optPickup_Click ()
End Sub
Sub optThick_Click ()
If cmdOrder.enabled Then    'Test in Order button on
     Call PlaceOrder        'Call PlaceOrder subroutine
End If
End Sub
Sub optThin_Click ()
If cmdOrder.enabled Then
    Call PlaceOrder     'Call PlaceOrder Subroutine
End If
End Sub
Sub PlaceOrder ()
Dim cnt As Integer
Dim chn As Integer
Dim topvalue As Integer
On Error GoTo ddefail      'Set Error Trap
If flgDDEON = False Then   'Test flag to see in DDE chnl
    Exit Sub               'If no chnl end sub
End If
starthere:                 'Label for Error Trap
    txtName.LinkMode = NONE              'Clear DDE channel
    txtName.LinkTopic = "Excel|[pizza.xls]sheet1"   ' Set link topic.
    txtName.LinkItem = "name"               ' Set link item.
    txtName.LinkMode = LINK_MANUAL          ' Set link mode.
    txtName.LinkPoke                        ' Put name in xl
    'txtName.LinkMode = NONE               'Clear DDE channel
    'Pass all the pizza info to xl through DDE Executes
    picPizza.LinkExecute "[select(""Cheese"")]"
    If chkTopping(0).Value = 1 Then topvalue = 1 Else topvalue = 0
    picPizza.LinkExecute "[Formula(" & topvalue & ")]"
    picPizza.LinkExecute "[select(""Pepperoni"")]"
    If chkTopping(1).Value = 1 Then topvalue = 1 Else topvalue = 0
    picPizza.LinkExecute "[Formula(" & topvalue & ")]"
    picPizza.LinkExecute "[select(""Mushrooms"")]"
    If chkTopping(2).Value = 1 Then topvalue = 1 Else topvalue = 0
    picPizza.LinkExecute "[Formula(" & topvalue & ")]"
    If optthin.Value = True Then
    picPizza.LinkExecute "[Run(""Thin"")]"     'Runs xl macro in sheet
    Else
    picPizza.LinkExecute "[Run(""Thick"")]"    'Runs xl macro in sheet
    End If
Exit Sub
ddefail:
    If Err = NOAPP Then     'Test if Err NoApp (282)
    rc = myStartXL()      'Try starting xl by calling Startxl procedure
    If rc = False Then  'If can't start xl then end Application
        End             'Ends App
    Else                'Else try DDE connection again
       Resume starthere     'Resume at StartAgain label
    End If
    Else                    'If not NoApp err call GenErr
    GenErr "PlaceOrder", Err, Error$   'GenErr pass procedure name, err and err msg
    End If
End Sub
Sub txtName_Change ()
    If Len(txtName) = 0 Then     'Test is text box blank
    cmdOrder.enabled = False 'Set order button to disabled
    mnuPizzaOrder.enabled = False
    Call myClearAll          'Call ClearAll subroutine
    Else
    If flgDDEON = False Then
    cmdOrder.enabled = True
        mnuPizzaOrder.enabled = True
    Else
        txtName.LinkPoke                        ' Put name in xl
    End If
    End If
End Sub
Sub UpdateName ()
End Sub